Celestin Apprentice 5/Apprentice-Release5.iso/Environments/Oberon⁄F™ 1.2/Preinstalled version/Form/Mod/Models/Models

Oberon Document | 1996-07-08 | 18.4 KB | 564 lines | [oODC/obnF]

Documents.StdDocumentDesc
Documents.DocumentDesc
Containers.ViewDesc
Views.ViewDesc
Stores.StoreDesc
Documents.ModelDesc
Containers.ModelDesc
Models.ModelDesc
Stores.ElemDesc
TextViews.StdViewDesc
TextViews.ViewDesc
TextModels.StdModelDesc
TextModels.ModelDesc
TextModels.AttributesDesc
Helvetica
Helvetica
StdStamps.StdViewDesc
Helvetica
Geneva
MODULE FormModels;
(** OmInc
    IMPORT Domains, Ports, Stores, Models, Views, Properties, Containers;
    CONST
        minViewSize* = 4 * Ports.point;    (** size of smallest embedded view **)
        maxViewSize* = 1000 * Ports.mm;    (** size of largest embedded view **)
        (* range of currently supported versions *)
        minVersion = 0; maxBaseVersion = 0; maxStdVersion = 0;
    TYPE
        (* interface types *)
        Model* = POINTER TO ModelDesc;
        ModelDesc* = RECORD (Containers.ModelDesc) END;
        Directory* = POINTER TO DirectoryDesc;
        DirectoryDesc* = RECORD END;
        Context* = POINTER TO ContextDesc;
        ContextDesc* = RECORD (Models.ContextDesc) END;
        Reader* = POINTER TO ReaderDesc;
        ReaderDesc* = RECORD
            view*: Views.View;    (** most recently read view **)
            l*, t*, r*, b*: LONGINT    (** bounding box of most recently read view **)
        END;
        Writer* = POINTER TO WriterDesc;
        WriterDesc* = RECORD END;
        UpdateMsg* = RECORD (Models.UpdateMsg)
            (** the receiver of this message must not switch on any marks **)
            l*, t*, r*, b*: LONGINT    (** (l < r) & (b < t) **)
        END;
        (* concrete types *)
        StdModel = POINTER TO StdModelDesc;
        StdContext = POINTER TO StdContextDesc;
        StdModelDesc = RECORD (ModelDesc)
            contexts: StdContext    (* list of views in form, ordered from bottom to top *)
        END;
        StdDirectory = POINTER TO StdDirectoryDesc;
        StdDirectoryDesc = RECORD (DirectoryDesc) END;
        StdContextDesc = RECORD (ContextDesc)
            next: StdContext;    (* next upper view *)
            form: StdModel;    (* form # NIL *)
            view: Views.View;    (* view # NIL *)
            l, t, r, b: LONGINT    (* (r - l >= minViewSize) & (b - t >= minViewSize) *)
        END;
        StdReader = POINTER TO StdReaderDesc;
        StdReaderDesc = RECORD (ReaderDesc)
            form: StdModel;    (* form # NIL *)
            pos: StdContext    (* next ReadView: read view above pos *)
        END;
        StdWriter = POINTER TO StdWriterDesc;
        StdWriterDesc = RECORD (WriterDesc)
            form: StdModel;    (* form # NIL *)
            pos: StdContext    (* next WriteView: insert view above pos *)
        END;
        FormOp = POINTER TO FormOpDesc;
        FormOpDesc = RECORD (Domains.OperationDesc)
            del, ins: StdContext;    (* ((del = NIL) # (ins = NIL)) OR (del = ins) *)
            pos: StdContext    (* ins # NIL => next Do: insert ins above pos *)
        END;
        ResizeOp = POINTER TO ResizeOpDesc;
        ResizeOpDesc = RECORD (Domains.OperationDesc)
            context: StdContext;    (* context # NIL *)
            l, t, r, b: LONGINT    (* (r - l >= minViewSize) & (b - t >= minViewSize) *)
        END;
        ReplaceViewOp = POINTER TO ReplaceViewDesc;
        ReplaceViewDesc = RECORD (Domains.OperationDesc)
            context: StdContext;    (* context # NIL *)
            view: Views.View    (* view # NIL *)
        END;
    VAR dir-, stdDir-: Directory;    (** (dir # NIL) & (stdDir # NIL) **)
    (** Model **)
    PROCEDURE (f: Model) Internalize* (VAR rd: Stores.Reader);
        VAR thisVersion: SHORTINT;
    BEGIN
        f.Internalize^(rd);
        IF rd.cancelled THEN RETURN END;
        rd.ReadVersion(minVersion, maxBaseVersion, thisVersion)
    END Internalize;
    PROCEDURE (f: Model) Externalize* (VAR wr: Stores.Writer);
    BEGIN
        f.Externalize^(wr);
        wr.WriteVersion(maxBaseVersion)
    END Externalize;
    PROCEDURE (f: Model) GetEmbeddingLimits* (VAR minW, maxW, minH, maxH: LONGINT);
    BEGIN
        minH := minViewSize; minW := minViewSize;
        maxH := maxViewSize; maxW := maxViewSize
    END GetEmbeddingLimits;
    PROCEDURE (f: Model) Insert* (v: Views.View; l, t, r, b: LONGINT);
        v # NIL    20
        v.init    21
        v.context = NIL    22
        l <= r    23
        t <= b    24
    BEGIN
        HALT(127)
    END Insert;
    PROCEDURE (f: Model) Delete* (v: Views.View);
    (** v in f    20 **)
    BEGIN
        HALT(127)
    END Delete;
    PROCEDURE (f: Model) Resize* (v: Views.View; l, t, r, b: LONGINT);
        v in f    20
        l <= r    21
        t <= b    22
    BEGIN
        HALT(127)
    END Resize;
    PROCEDURE (f: Model) PutAbove* (v, pos: Views.View);
        v in f    20
        (pos = NIL) OR (pos in f)    21
    BEGIN
        HALT(127)
    END PutAbove;
    PROCEDURE (f: Model) Move* (v: Views.View; dx, dy: LONGINT);
    (** v in f    20 **)
    BEGIN
        HALT(127)
    END Move;
    PROCEDURE (f: Model) Copy* (VAR v: Views.View; dx, dy: LONGINT);
    (** v in f    20 **)
    BEGIN
        HALT(127)
    END Copy;
    PROCEDURE (f: Model) NewReader* (old: Reader): Reader;
    BEGIN
        HALT(127)
    END NewReader;
    PROCEDURE (f: Model) NewWriter* (old: Writer): Writer;
    BEGIN
        HALT(127)
    END NewWriter;
    PROCEDURE (f: Model) ViewAt* (x, y: LONGINT): Views.View;
    BEGIN
        HALT(127)
    END ViewAt;
    PROCEDURE (f: Model) NofViews* (): INTEGER;
    BEGIN
        HALT(127)
    END NofViews;
    (** Directory **)
    PROCEDURE (d: Directory) New* (): Model;
    BEGIN
        HALT(127)
    END New;
    (** Context **)
    PROCEDURE (c: Context) ThisModel* (): Model;
    BEGIN
        RETURN NIL
    END ThisModel;
    PROCEDURE (c: Context) GetRect* (VAR l, t, r, b: LONGINT);
    BEGIN
        HALT(127)
    END GetRect;
    (** Reader **)
    PROCEDURE (r: Reader) Set* (pos: Views.View);
    (** (pos = NIL) OR (pos in r's form)    20 **)
    BEGIN
        HALT(127)
    END Set;
    PROCEDURE (r: Reader) ReadView* (VAR v: Views.View);
    BEGIN
        HALT(127)
    END ReadView;
    (** Writer **)
    PROCEDURE (w: Writer) Set* (pos: Views.View);
    (** (pos = NIL) OR (pos in w's form)    20 **)
    BEGIN
        HALT(127)
    END Set;
    PROCEDURE (w: Writer) WriteView* (v: Views.View; l, t, r, b: LONGINT);
        v # NIL    20
        v.init    21
        v.context = NIL    22
        l <= r    23
        t <= b    24
    BEGIN
        HALT(127)
    END WriteView;
    (* StdModel *)
    PROCEDURE ThisContext (f: StdModel; view: Views.View): StdContext;
        VAR c: StdContext;
    BEGIN
        c := f.contexts; WHILE (c # NIL) & (c.view # view) DO c := c.next END;
        RETURN c
    END ThisContext;
    PROCEDURE NewContext (form: StdModel; view: Views.View; l, t, r, b: LONGINT): StdContext;
        VAR c: StdContext;
    BEGIN
        ASSERT(form # NIL, 20); ASSERT(view.context = NIL, 21);
        IF r - l < minViewSize THEN r := l + minViewSize END;
        IF b - t < minViewSize THEN b := t + minViewSize END;
        NEW(c); c.form := form; c.view := view; c.l := l; c.t := t; c.r := r; c.b := b;
        view.InitContext(c);
        RETURN c
    END NewContext;
    PROCEDURE InsertAbove (c, pos: StdContext);
    BEGIN
        IF pos = NIL THEN
            c.next := NIL; c.form.contexts := c
        ELSE
            c.next := pos.next; pos.next := c
        END
    END InsertAbove;
    PROCEDURE (f: StdModel) Internalize (VAR rd: Stores.Reader);
        VAR thisVersion: SHORTINT; top, h: StdContext; v: Views.View; l, t, r, b: LONGINT;
    BEGIN
        f.Internalize^(rd);
        IF ~rd.cancelled THEN
            rd.ReadVersion(minVersion, maxStdVersion, thisVersion);
            IF ~rd.cancelled THEN
                Views.ReadView(rd, v); top := NIL;
                WHILE v # NIL DO
                    rd.ReadLInt(l); rd.ReadLInt(t); rd.ReadLInt(r); rd.ReadLInt(b);
                    h := NewContext(f, v, l, t, r, b);
                    InsertAbove(h, top); top := h;
                    Views.ReadView(rd, v)
                END
            END
        END
    END Internalize;
    PROCEDURE (f: StdModel) Externalize (VAR wr: Stores.Writer);
        VAR c: StdContext; p: Properties.StorePref;
    BEGIN
        f.Externalize^(wr);
        wr.WriteVersion(maxStdVersion);
        c := f.contexts;
        WHILE c # NIL DO
            p.view := c.view; Views.HandlePropMsg(c.view, p);
            IF p.view # NIL THEN    (* view is not temporary *)
                Views.WriteView(wr, p.view);
                wr.WriteLInt(c.l); wr.WriteLInt(c.t); wr.WriteLInt(c.r); wr.WriteLInt(c.b)
            END;
            c := c.next
        END;
        wr.WriteStore(NIL)
    END Externalize;
    PROCEDURE (f: StdModel) InitDomain (d: Domains.Domain);
        VAR c: StdContext;
    BEGIN    (* propagate domain to all embedded views *)
        f.InitDomain^(d);
        c := f.contexts; WHILE c # NIL DO c.view.InitDomain(d); c := c.next END
    END InitDomain;
    PROCEDURE (f: StdModel) CopyAllFrom (source: Models.Model);
        VAR c, top, h: StdContext;
    BEGIN
        WITH source: StdModel DO
            c := source.contexts; top := NIL;
            WHILE c # NIL DO
                h := NewContext(f, Views.CopyOf(c.view, Views.deep), c.l, c.t, c.r, c.b);
                InsertAbove(h, top); top := h;
                c := c.next
            END
        END
    END CopyAllFrom;
    PROCEDURE (f: StdModel) InitFrom (source: Models.Model);
    BEGIN
        f.contexts := NIL
    END InitFrom;
    PROCEDURE (f: StdModel) ReplaceView (old, new: Views.View);
        VAR op: ReplaceViewOp; c: StdContext;
    BEGIN
        c := ThisContext(f, old); ASSERT(c # NIL, 20);
        ASSERT(new # NIL, 21); ASSERT((new.context = NIL) OR (new.context = c), 23);
        IF old # new THEN
            NEW(op); op.context := c; op.view := new;
            Models.Do(f, "#System:ReplaceView", op)
        END
    END ReplaceView;
    PROCEDURE (f: StdModel) Insert (v: Views.View; l, t, r, b: LONGINT);
        VAR op: FormOp; c, h, top: StdContext;
    BEGIN
        ASSERT(v # NIL, 20); ASSERT(v.context = NIL, 22);
        ASSERT(l <= r, 23); ASSERT(t <= b, 24);
        h := f.contexts; top := NIL; WHILE h # NIL DO top := h; h := h.next END;
        c := NewContext(f, v, l, t, r, b);
        NEW(op); op.del := NIL; op.ins := c; op.pos := top;
        Models.Do(f, "#System:Insertion", op)
    END Insert;
    PROCEDURE (f: StdModel) Delete (v: Views.View);
        VAR op: FormOp; c: StdContext;
    BEGIN
        c := ThisContext(f, v); ASSERT(c # NIL, 20);
        NEW(op); op.del := c; op.ins := NIL; op.pos := NIL;
        Models.Do(f, "#System:Deletion", op)
    END Delete;
    PROCEDURE (f: StdModel) Resize (v: Views.View; l, t, r, b: LONGINT);
        VAR op: ResizeOp; c: StdContext;
    BEGIN
        c := ThisContext(f, v); ASSERT(c # NIL, 20);
        ASSERT(r >= l, 21); ASSERT(b >= t, 22);
        IF r - l < minViewSize THEN r := l + minViewSize END;
        IF b - t < minViewSize THEN b := t + minViewSize END;
        NEW(op); op.context := c; op.l := l; op.t := t; op.r := r; op.b := b;
        Models.Do(f, "#System:Resizing", op)
    END Resize;
    PROCEDURE (f: StdModel) PutAbove (v, pos: Views.View);
        VAR op: FormOp; c, d: StdContext;
    BEGIN
        c := ThisContext(f, v); ASSERT(c # NIL, 20);
        d := ThisContext(f, pos); ASSERT((pos = NIL) OR (d # NIL), 21);
        IF v # pos THEN
            NEW(op); op.del := c; op.ins := c; op.pos := d;
            Models.Do(f, "#Form:ChangeZOrder", op)
        END
    END PutAbove;
    PROCEDURE (f: StdModel) Move (v: Views.View; dx, dy: LONGINT);
        VAR op: ResizeOp; c: StdContext;
    BEGIN
        c := ThisContext(f, v); ASSERT(c # NIL, 20);
        IF (dx # 0) OR (dy # 0) THEN
            NEW(op); op.context := c;
            op.l := c.l + dx; op.t := c.t + dy; op.r := c.r + dx; op.b := c.b + dy;
            Models.Do(f, "#System:Moving", op)
        END
    END Move;
    PROCEDURE (f: StdModel) Copy (VAR v: Views.View; dx, dy: LONGINT);
        VAR op: FormOp; c, h, top: StdContext;
    BEGIN
        c := ThisContext(f, v); ASSERT(c # NIL, 20);
        h := f.contexts; top := NIL; WHILE h # NIL DO top := h; h := h.next END;
        h := NewContext(f, Views.CopyOf(v, Views.deep), c.l + dx, c.t + dy, c.r + dx, c.b + dy);
        NEW(op); op.del := NIL; op.ins := h; op.pos := top;
        Models.Do(f, "#System:Copying", op);
        v := h.view
    END Copy;
    PROCEDURE (f: StdModel) NewReader (old: Reader): Reader;
        VAR r: StdReader;
    BEGIN
        IF (old = NIL) OR ~(old IS StdReader) THEN NEW(r) ELSE r := old(StdReader) END;
        r.view := NIL; r.form := f; r.pos := NIL; RETURN r
    END NewReader;
    PROCEDURE (f: StdModel) NewWriter (old: Writer): Writer;
        VAR w: StdWriter;
    BEGIN
        IF (old = NIL) OR ~(old IS StdWriter) THEN NEW(w) ELSE w := old(StdWriter) END;
        w.form := f; w.pos := NIL; RETURN w
    END NewWriter;
    PROCEDURE (f: StdModel) ViewAt (x, y: LONGINT): Views.View;
        VAR c, top: StdContext;
    BEGIN
        c := f.contexts; top := NIL;
        WHILE c # NIL DO
            IF (x >= c.l) & (y >= c.t) & (x < c.r) & (y < c.b) THEN top := c END;
            c := c.next
        END;
        IF top = NIL THEN RETURN NIL ELSE RETURN top.view END
    END ViewAt;
    PROCEDURE (f: StdModel) NofViews (): INTEGER;
        VAR c: StdContext; n: INTEGER;
    BEGIN
        n := 0; c := f.contexts; WHILE c # NIL DO INC(n); c := c.next END;
        RETURN n
    END NofViews;
    (* StdContext *)
    PROCEDURE (c: StdContext) ThisModel (): Model;
    BEGIN
        RETURN c.form
    END ThisModel;
    PROCEDURE (c: StdContext) GetSize (VAR w, h: LONGINT);
    BEGIN
        w := c.r - c.l; h := c.b - c.t
    END GetSize;
    PROCEDURE (c: StdContext) SetSize (w, h: LONGINT);
        VAR w0, h0: LONGINT;
    BEGIN
        w0 := c.r - c.l; h0 := c.b - c.t; ASSERT(w0 > 0, 100); ASSERT(h0 > 0, 101);
        Properties.PreferredSize(
                c.view, minViewSize, maxViewSize, minViewSize, maxViewSize, w0, h0, w, h);
        IF (w # w0) OR (h # h0) THEN
            c.form.Resize(c.view, c.l, c.t, c.l + w, c.t + h)
        END
    END SetSize;
    PROCEDURE (c: StdContext) Normalize (): BOOLEAN;
    BEGIN
        RETURN FALSE
    END Normalize;
    PROCEDURE (c: StdContext) GetRect (VAR l, t, r, b: LONGINT);
    BEGIN
        l := c.l; t := c.t; r := c.r; b := c.b
    END GetRect;
    (* StdDirectory *)
    PROCEDURE (d: StdDirectory) New (): Model;
        VAR f: StdModel;
    BEGIN
        NEW(f); RETURN f
    END New;
    (* StdReader *)
    PROCEDURE (r: StdReader) Set (pos: Views.View);
        VAR c: StdContext;
    BEGIN
        IF pos = NIL THEN c := NIL ELSE c := ThisContext(r.form, pos); ASSERT(c # NIL, 20) END;
        r.view := NIL; r.l := 0; r.t := 0; r.r := 0; r.b := 0;
        r.pos := c
    END Set;
    PROCEDURE (r: StdReader) ReadView (VAR v: Views.View);
        VAR c: StdContext;
    BEGIN
        c := r.pos;
        IF c = NIL THEN c := r.form.contexts ELSE c := c.next END;
        IF c # NIL THEN
            r.view := c.view; r.l := c.l; r.t := c.t; r.r := c.r; r.b := c.b;
            r.pos := c
        ELSE
            r.view := NIL; r.l := 0; r.t := 0; r.r := 0; r.b := 0
        END;
        v := r.view
    END ReadView;
    (* StdWriter *)
    PROCEDURE (w: StdWriter) Set (pos: Views.View);
        VAR c: StdContext;
    BEGIN
        IF pos = NIL THEN c := NIL ELSE c := ThisContext(w.form, pos); ASSERT(c # NIL, 20) END;
        w.pos := c
    END Set;
    PROCEDURE (w: StdWriter) WriteView (v: Views.View; l, t, r, b: LONGINT);
        VAR c: StdContext;
    BEGIN
        ASSERT(v # NIL, 20); ASSERT(v.context = NIL, 22);
        ASSERT(l <= r, 23); ASSERT(t <= b, 24);
        c := NewContext(w.form, v, l, t, r, b);
        IF w.pos = NIL THEN
            c.next := w.form.contexts; w.form.contexts := c
        ELSE
            c.next := w.pos.next; w.pos.next := c
        END;
        w.pos := c
    END WriteView;
    (* operations *)
    PROCEDURE Update (c: StdContext);
        VAR msg: UpdateMsg;
    BEGIN
        msg.l := c.l; msg.t := c.t; msg.r := c.r; msg.b := c.b; Models.Broadcast(c.form, msg)
    END Update;
    PROCEDURE (op: FormOp) Do;
        VAR f: StdModel; c, p, pos: StdContext;
    BEGIN
        (* delete *)
        pos := NIL;
        c := op.del;
        IF c # NIL THEN
            f := c.form; ASSERT(f # NIL, 100);
            p := f.contexts; ASSERT(p # NIL, 101);
            IF p = c THEN
                f.contexts := c.next
            ELSE
                WHILE p.next # c DO p := p.next; ASSERT(p # NIL, 102) END;
                pos := p; p.next := c.next
            END;
            c.next := NIL;
            Update(c)
        END;
        (* insert *)
        c := op.ins;
        IF c # NIL THEN
            f := c.form; ASSERT(f # NIL, 103);
            p := f.contexts;
            IF op.pos = NIL THEN
                c.next := f.contexts; f.contexts := c
            ELSE
                c.next := op.pos.next; op.pos.next := c
            END;
            c.view.InitDomain(f.domain);
            Update(c)
        END;
        (* swap ins and del for undo *)
        p := op.del; op.del := op.ins; op.ins := p; op.pos := pos
    END Do;
    PROCEDURE (op: ResizeOp) Do;
        VAR c: StdContext; l, t, r, b: LONGINT;
    BEGIN
        c := op.context;
        (* save old state of context *)
        l := c.l; t := c.t; r := c.r; b := c.b;
        Update(c);
        (* set new state of context *)
        c.l := op.l; c.t := op.t; c.r := op.r; c.b := op.b;
        Update(c);
        (* old state is new undo state *)
        op.l := l; op.t := t; op.r := r; op.b := b
    END Do;
    PROCEDURE (op: ReplaceViewOp) Do;
        VAR c: StdContext; view: Views.View;
    BEGIN
        c := op.context;
        (* save old state of context *)
        view := c.view;
        (* set new state of context *)
        c.view := op.view; c.view.InitContext(c);
        Update(c);
        (* old state is new undo state *)
        op.view := view
    END Do;
    (** miscellaneous **)
    PROCEDURE New* (): Model;
    BEGIN
        RETURN dir.New()
    END New;
    PROCEDURE Clone* (source: Model): Model;
        VAR st: Stores.Store; m: Model;
    BEGIN
        ASSERT(source # NIL, 20);
        st := Stores.Clone(source); m := st(Model);
        m.InitFrom(source);
        RETURN m
    END Clone;
    PROCEDURE Copy* (source: Model): Model;
        VAR st: Stores.Store; m: Model;
    BEGIN
        ASSERT(source # NIL, 20);
        st := Stores.Clone(source); m := st(Model);
        m.CopyAllFrom(source);
        RETURN m
    END Copy;
    PROCEDURE GetRect* (v: Views.View; VAR l, t, r, b: LONGINT);
        v # NIL    20
        v.context # NIL    21
        v.context IS Context    22
    BEGIN
        ASSERT(v # NIL, 20); ASSERT(v.context # NIL, 21); ASSERT(v.context IS Context, 22);
        v.context(Context).GetRect(l, t, r, b)
    END GetRect;
    PROCEDURE SetDir* (d: Directory);
    (** d # NIL    20 **)
    BEGIN
        ASSERT(d # NIL, 20); dir := d
    END SetDir;
    PROCEDURE Init;
        VAR d: StdDirectory;
    BEGIN
        NEW(d); dir := d; stdDir := d
    END Init;
BEGIN
    Init
END FormModels.
TextControllers.StdCtrlDesc
TextControllers.ControllerDesc
Containers.ControllerDesc
Controllers.ControllerDesc
TextRulers.StdRulerDesc
TextRulers.RulerDesc
TextRulers.StdStyleDesc
TextRulers.StyleDesc
TextRulers.AttributesDesc
Helvetica
Documents.ControllerDesc